Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/scheme/pcscheme/geneva/sources.exe/SOURCES/LISP/SEQUENCE.LSP

Lisp/Scheme | 1990-09-09 | 13.9 KB | 451 lines

;; PC Scheme Common Lisp Compatibility Package
;;
;; (c) Copyright 1990 Carl W. Hoffman.  All rights reserved.
;;
;; This file may be freely copied, distributed, or modified for non-commercial
;; use provided that this copyright notice is not removed.  For further
;; information about other utilities for Common Lisp or Scheme, contact the
;; following address:
;;
;;   Carl W. Hoffman, 363 Marlborough Street, Boston, MA 02115, U.S.A.
;;   Internet: [e-mail]    CompuServe: 76416,3365    Fax: [phone]

;; Sequences and Lists

;; Note that we can't use the name SEQUENCE (or the name of any other Scheme
;; special form) as the name of a parameter.  Actually, SEQUENCE isn't defined
;; in R^3RS, but it is used in Abelson & Sussman, so PC Scheme defines it
;; anyway.

;; Taken from CLtL first edition p. 265

(defun list-length (x)
  (do ((n 0 (+ n 2))                ; Counter
       (fast x (cddr fast))         ; Fast pointer: leaps by 2.
       (slow x (cdr slow)))         ; Slow pointer: leaps by 1.
      (nil)
    ;; If fast pointer hist the end, return the count.
    (when (endp fast) (return n))
    (when (endp (cdr fast)) (return (+ n 1)))
    ;; If fast pointer eventually equals slow pointer,
    ;;  then we must be stuck in a circular list.
    ;; (A deeper property is the converse:  if we are
    ;;  stuck in a circular list, then eventually the
    ;;  fast pointer will equal the slow pointer.
    ;;  That fact justifies this implementation.)
    (when (and (eq fast slow) (> n 0)) (return nil))))

(defun nth (n list)
  (when (or (not (integerp n)) (< n 0))
    (error "The first argument to NTH, ~S, is not a non-negative integer."
           n))
  (list-ref list n))

(defun nthcdr (n list)
  (when (or (not (integerp n)) (< n 0))
    (error "The first argument to NTHCDR, ~S, is not a non-negative integer."
           n))
  (list-tail list n))

;; APPEND! is the PC Scheme name for NCONC.

(defun nconc (&rest lists)
  (do ((l lists (cdr l)))
      ((null l))
    (let ((list (car l)))
      (cond ((null list))
            ((not (consp list))
             (error "One of the arguments to NCONC, ~S, is not a list."
                    list))
            (else
              (do ((x list (cdr x)))
                  (nil)
                (when (null (cdr x))
                  (setf (cdr x) (cadr l))
                  (return)))))))
   (car lists))

;; This could be written more efficiently.

(defun nreconc (x y)
  (nconc (nreverse x) y))

;; p. 250
;; Just lists for now.

(defun some (predicate seq)
  (dolist (x seq)
    (let ((y (funcall predicate x)))
      (when y
        (return-from some y))))
  nil)

(defun every (predicate seq)
  (dolist (x seq)
    (unless (funcall predicate x)
      (return-from every nil)))
  t)

(defun notany (predicate seq)
  (dolist (x seq)
    (when (funcall predicate x)
      (return-from every nil)))
  t)

(defun notevery (predicate seq)
  (dolist (x seq)
    (unless (funcall predicate x)
      (return-from notevery t)))
  nil)

(defun-clcp %%check-index-arg (fcn name value)
  (unless (or (null value)
              (and (integerp value) (>= value 0)))
    (error "The :~A argument to ~A, ~S, is not a non-negative integer or NIL."
           name fcn value)))

(defmacro check-index-arg (fcn var)
  `(%%check-index-arg ',fcn ',var ,var))

(defun-clcp %%compare-index-args
            (fcn start-name end-name start-value end-value)
  (when (> start-value end-value)
    (error "The :~A argument to ~A, ~S, is greater than the :~A argument, ~S."
           start-name fcn start-value end-name end-value)))

(defmacro compare-index-args (fcn start-var end-var)
  `(%%compare-index-args ',fcn ',start-var ',end-var ,start-var ,end-var))

(defun-clcp %%fill (seq item start end)
  (check-index-arg fill start)
  (check-index-arg fill end)
  (unless start
    (setq start 0))
  (unless end
    (setq end (length seq)))
  (compare-index-args fill start end)
  (cond ((listp seq)
         (let ((cdr-seq seq))
           (dotimes (i start)
             (pop cdr-seq))
           (dotimes (i (- end start))
             (when (null cdr-seq) (return))
             (setf (car cdr-seq) item)
             (pop cdr-seq))))
        ((stringp seq)
         (substring-fill! seq start end item))
        ((vectorp seq)
         (do ((i start (1+ i)))
             ((= i end))
           (setf (svref seq i) item)))
        (else
          (error "The first argument to FILL, ~S, is not a sequence."
                 seq)))
  seq)

(defun-clcp %%replace-string (string1 string2 start1 start2 count)
  (dotimes (i count)
    (setf (char string1 (+ start1 i))
          (char string2 (+ start2 i)))))

(defun-clcp %%replace-vector (vector1 vector2 start1 start2 count)
  (dotimes (i count)
    (setf (svref vector1 (+ start1 i))
          (svref vector2 (+ start2 i)))))

(defun-clcp %%replace (seq1 seq2 start1 end1 start2 end2)
  (check-index-arg replace start1)
  (check-index-arg replace end1)
  (check-index-arg replace start2)
  (check-index-arg replace end2)
  (unless start1
    (setq start1 0))
  (unless start2
    (setq start2 0))
  (unless end1
    (setq end1 (length seq1)))
  (unless end2
    (setq end2 (length seq2)))
  (compare-index-args replace start1 end1)
  (compare-index-args replace start2 end2)
  (let ((count (min (- end1 start1) (- end2 start2))))
    (cond ((listp seq1)
           (unless (listp seq2)
             (error "The second argument to REPLACE, ~S, is not a list."
                    seq2))
           (let ((cdr-seq1 seq1)
                 (cdr-seq2 seq2))
             (dotimes (i start1) (pop cdr-sq1))
             (dotimes (i start2) (pop cdr-sq2))
             (dotimes (i count)
               (setf (car cdr-sq1) (car cdr-sq2))
               (pop cdr-sq1)
               (pop cdr-sq2))))
          ((stringp seq1)
           (unless (stringp seq2)
             (error "The second argument to REPLACE, ~S, is not a string."
                    seq2))
           (%%replace-string seq1 seq2 start1 start2 count))
          ((vectorp seq1)
           (unless (vectorp seq2)
             (error "The second argument to REPLACE, ~S, is not a vector."
                    seq2))
           (%%replace-vector seq1 seq2 start1 start2 count))
          (else
            (error "The first argument to REPLACE, ~S, is not a sequence."
                   seq1))))
  seq1)

;; This is defined for sequences but is currently only implemented for lists.

(defun-clcp %%delete (thing seq test count)
  (unless (or (null count)
              (and (integerp count) (>= count 0)))
    (error "The :COUNT argument to DELETE, ~S, ~
            is not a non-negative integer or NIL."
           count))
  (if (and (integerp count) (<= count 0))
      seq
      (let ((i count)
            (previous nil)
            (result seq))
        (do ((l seq (cdr l)))
            ((or (null l)
                 (and i (zerop i))))
          (let ((x (car l)))
            (if (not (or (and test (test thing x))
                         (eql thing x)))
                (setq previous l)
                (progn
                  (when i (decf i))
                  (if (eq result l)
                      (pop result)
                      (progn
                        (if (null previous)
                            (setq previous result))
                        (setf (cdr previous) (cdr l))))))))
        result)))

;; This is defined for sequences but is currently only implemented for lists.

(defun-clcp %%find (item seq test key)
  (do ((l seq (cdr l)))
      ((null l) nil)
    (let* ((x (car l))
           (kx (if key (key x) x)))
      (when (or (and test (test item kx))
                (eql item kx))
        (return x)))))

(defun-clcp %%member (item list test key)
  (do ((l list (cdr l)))
      ((null l) nil)
    (let ((x (car l)))
      (if key (key x))
      (when (or (and test (test item x))
                (eql item x))
        (return l)))))

(defun-clcp %%assoc (item alist test)
  (do ((l alist (cdr l)))
      ((null l) nil)
    (let* ((pair (car l))
           (key (car pair)))
      (when (or (and test (test item key))
                (eql item key))
        (return pair)))))

;; Extend this to indicate when a keyword is not present in ARG-LIST.

(defun-clcp parse-keywords (key-list arg-list)
  (let ((result nil))
    ;; Scan the list of defined keywords.
    (do ((k key-list (cdr k)))
        ((null k))
      (let ((seen? nil))
        (do ((a arg-list (cddr a)))
            ((null a))
          (when (null (cdr a))
            (error "The keyword ~A appears at the end of the argument list."
                   (car a)))
          (when (eq (car k) (car a))
            (when seen?
              (error "The keyword ~A appears twice in the argument list."
                     (car a)))
            (push (cadr a) result)
            (setq seen? t)))
        (unless seen?
          (push nil result))))
    ;; Scan the arguments looking for undefined keywords.
    (do ((a arg-list (cddr a)))
        ((null a))
      (unless (member (car a) key-list)
        (error "The keyword ~A is undefined." (car a))))
    (nreverse result)))

;; These only allow the use of keywords at compile time.  Later, when we have
;; a real translator, these should be reimplemented as functions which
;; recognize keyword arguments at runtime.

;; p. 252

(defmacro fill (seq item &rest keywords)
  `(%%fill
     ,seq ,item . ,(parse-keywords '(:start :end) keywords)))

(defmacro replace (seq1 seq2 &rest keywords)
  `(%%replace
     ,seq1 ,seq2 . ,(parse-keywords '(:start1 :end1 :start2 :end2) keywords)))

;; p. 254

(defmacro delete (item list &rest keywords)
  (let ((parsed (parse-keywords '(:test :count) keywords)))
    (if (every (function null) parsed)
        `(delq! ,item ,list)
        `(%%delete ,item ,list . ,parsed))))

;; p. 257

(defmacro find (item seq &rest keywords)
  `(%%find ,item ,seq . ,(parse-keywords '(:test :key) keywords)))

;; p. 273

(defun subst (new old tree)
  (cond ((eq old tree)
         new)
        ((not (consp tree))
         tree)
        (else
          (cons (subst new old (car tree)) (subst new old (cdr tree))))))

;; p. 274

(defun nsubst (new old tree)
  (cond ((eq old tree)
         new)
        ((not (consp tree))
         tree)
        (else
          (setf (car tree) (nsubst new old (car tree)))
          (setf (cdr tree) (nsubst new old (cdr tree)))
          tree)))

;; p. 275

(defmacro member (item list &rest keywords)
  (let ((parsed (parse-keywords '(:test :key) keywords)))
    (if (every (function null) parsed)
        `(scheme-member ,item ,list)
        `(%%member ,item ,list . ,parsed))))

;; p. 276

(defun adjoin (item list)
  (if (member item list) list (cons item list)))

;; p. 280

(defmacro assoc (item alist &rest keywords)
  (let ((parsed (parse-keywords '(:test) keywords)))
    (if (null (first parsed))
        `(scheme-assoc ,item ,alist)
        `(%%assoc ,item ,alist . ,parsed))))

;; p. 248

(defun elt (seq index)
  (cond ((stringp seq)
         (string-ref seq index))
        ((vectorp seq)
         (vector-ref seq index))
        ((listp seq)
         (nth index seq))
        (else
         (error "The first argument to ELT, ~S, is not a sequence." seq))))

(defun subseq (seq start &optional end)
  (cond ((listp seq)
         (dotimes (i start) (pop seq))
         (if (null end)
             (mapcar (lambda (x) x) seq)
             (let ((result '()))
               (dotimes (i (- end start))
                 (push (pop seq) result))
               (nreverse result))))
        ((vectorp seq)
         (let* ((length (- (or end (vector-length seq)) start))
                (new-vector (make-vector length)))
           (dotimes (i length)
             (setf (svref new-vector i) (svref seq (+ i start))))
           new-vector))
        ((stringp seq)
         (substring seq start (or end (string-length seq))))
        (else
          (error "The first argument to SUBSEQ, ~S, is not a sequence."
                 seq))))

(defun copy-seq (seq)
  (cond ((listp seq)
         (mapcar (lambda (x) x) seq))
        ((stringp seq)
         (let* ((length (string-length seq))
                (new-string (make-string length)))
           (dotimes (i length)
             (setf (char new-string i) (char seq i)))
           new-string))
        ((vectorp seq)
         (let* ((length (vector-length seq))
                (new-vector (make-vector length)))
           (dotimes (i length)
             (setf (svref new-vector i) (svref seq i)))
           new-vector))
        (else
          (error "The first argument to COPY-SEQ, ~S, is not a sequence."
                 seq))))

(defun length (seq)
  (cond ((listp seq)
         (scheme-length seq))
        ((stringp seq)
         (string-length seq))
        ((vectorp seq)
         (vector-length seq))
        (else
          (error "The first argument to LENGTH, ~S, is not a sequence."
                 seq))))

(defun concatenate (type &rest sequences)
  (case type
    (string
      (apply string-append sequences))
    (list
      (apply append sequences))
    (else
      (error "The first argument to CONCATENATE, ~S, ~
              is not a known sequence type specifier."
             type))))

;; p. 268

(defun copy-list (list)
  (if (null list)
      ()
      (let* ((result (cons (car list) ()))
             (next result))
        (do ((l (cdr list) (cdr l)))
            ((null l))
          (setf (cdr next) (cons (car l) ()))
          (pop next))
        result)))

;; p. 302

(defmacro make-string (size &rest keywords)
  (let ((initial-element
          (first (parse-keywords '(:initial-element) keywords))))
    (if (null initial-element)
        `(scheme-make-string ,size)
        `(scheme-make-string ,size ,initial-element))))